SuperHack/SuperHack CD.bin/CODING/DELPHI/EZDSL200.ZIP/EZDSLBTR.PAS

Pascal/Delphi Source File | 1996-03-13 | 41.2 KB | 1,357 lines

{===EZDSLBTR==========================================================

Part of the Delphi Structures Library--the binary tree, the binary
search tree and the red-black binary search tree.

EZDSLBTR is Copyright (c) 1993, 1996 by  Julian M. Bucknall

VERSION HISTORY
13Mar96 JMB 2.00 release for Delphi 2.0
18Jun95 JMB 1.00 conversion of EZStrucs to Delphi
======================================================================}
{ Copyright (c) 1993, 1996, Julian M. Bucknall. All Rights Reserved   }

unit EZDSLBtr;

{$I EZDSLDEF.INC}
{---Place any compiler options you require here-----------------------}


{---------------------------------------------------------------------}
{$I EZDSLOPT.INC}

interface

uses
  SysUtils,
  WinTypes,
  WinProcs,
  Classes,
  EZDSLCts,
  EZDSLSup,
  EZDSLBse,
  {$IFNDEF UseTreeRecursion}
  EZDSLStk,
  {$ENDIF}
  EZDSLQue;

type
  TBinTree = class(TAbstractContainer)
    {-Binary tree object}
    private
      Rt        : PNode;
      FTravType : TTraversalType;

    public
      constructor Create(DataOwner : boolean); override;
      constructor Clone(Source : TAbstractContainer;
                        DataOwner : boolean; NewCompare : TCompareFunc); override;

      function  Delete(Cursor : TTreeCursor) : TTreeCursor; virtual;
      procedure Empty; override;
      function  Erase(Cursor : TTreeCursor) : TTreeCursor;
      function  Examine  (Cursor : TTreeCursor) : pointer;
      procedure Insert   (var Cursor : TTreeCursor; aData : pointer); virtual;
      function  IsLeaf   (Cursor : TTreeCursor) : boolean;
      function  IsRoot   (Cursor : TTreeCursor) : boolean;
      function  Iterate(Action : TIterator; Backwards : boolean;
                        ExtraData : pointer) : TTreeCursor;
      procedure Join(Cursor : TTreeCursor; Tree : TBinTree); virtual;
      function  Left(Cursor : TTreeCursor) : TTreeCursor;
      function  Parent(Cursor : TTreeCursor) : TTreeCursor;
      function  Replace  (Cursor : TTreeCursor; aData : pointer) : pointer; virtual;
      function  Right(Cursor : TTreeCursor) : TTreeCursor;
      function  Root : TTreeCursor;
      function  Search   (var Cursor : TTreeCursor; aData : pointer) : boolean; virtual;

      property TraversalType : TTraversalType
         read FTravType
         write FTravType;
  end;

  TBinSearchTree = class(TBinTree)
    {-Binary search tree object}
    protected
      procedure bsSwapData(OldCursor, NewCursor : TTreeCursor); virtual;

    public
      constructor Clone(Source : TAbstractContainer;
                        DataOwner : boolean; NewCompare : TCompareFunc); override;

      function  Delete (Cursor : TTreeCursor) : TTreeCursor; override;
      procedure Insert (var Cursor : TTreeCursor; aData : pointer); override;
      procedure Join(Cursor : TTreeCursor; Tree : TBinTree); override;
      function  Replace(Cursor : TTreeCursor; aData : pointer) : pointer; override;
      function  Search (var Cursor : TTreeCursor; aData : pointer) : boolean; override;
  end;

  TrbSearchTree = class(TBinSearchTree)
    {-Balanced binary search tree object (Red-black tree)}
    private
      DeletedNodeWasBlack : boolean;

    protected
      procedure bsSwapData(OldCursor, NewCursor : TTreeCursor); override;
      function  rbPromote(Cursor : TTreeCursor) : TTreeCursor;

    public
      function  Delete (Cursor : TTreeCursor) : TTreeCursor; override;
      procedure Insert (var Cursor : TTreeCursor; aData : pointer); override;
  end;

implementation

{Notes: the TTreeCursor is a pointer and a boolean wrapped in one. In
        Delphi, pointers allocated on the heap have a granularity of
        4 bytes, ie their offset always has the lower 2 bits clear.
        We use bit 0 of the pointer as a left child, right child
        indicator (left = 0, right = 1). Thus the TTreeCursor is a
        pointer to the parent's node and an indicator to the relevant
        child.
        The parent link field of a node (the PKC) is a pointer and two
        booleans wrapped in one. The pointer is the parent's node as
        for TTreeCursors, bit 0 is the child (so a node always knows
        which child it is) and we use bit 1 of the pointer as a color
        bit for red-black trees (black = 0, red = 1). This by the way
        violates pure OOP design where ancestor aren't supposed to
        'know' about their descendants, but as I wrote the binary
        tree implementations in one go...
        The following 6 routines all help maintain these 'packed'
        variables.                                                    }

{-Given a cursor, returns the address of node's parent node}
function Dad(X : TTreeCursor) : PNode;
  {$IFDEF Win32}
  begin
    Result := PNode(X and $FFFFFFFC);
  end;
  {$ELSE}
  inline($58/            {pop ax      get offset}
         $25/$FC/$FF/    {and ax, XX  clear color and child bits}
         $5A);           {pop dx      get seg/sel}
  {$ENDIF}
{--------}
{-Given a cursor, returns the child relationship the node has with its parent}
function Kid(X : TTreeCursor) : TChild;
  {$IFDEF Win32}
  begin
    Result := TChild(X and $1);
  end;
  {$ELSE}
  inline($58/            {pop ax      get offset}
         $25/$01/$00/    {and ax, 1   isolate child bit}
         $5A);           {pop dx      toss seg/sel}
  {$ENDIF}
{--------}
{-Given a cursor, returns the address of the node being pointed to}
function GetNode(Cursor : TTreeCursor) : PNode;
  {$IFDEF Win32}
  register;
  asm
    mov edx, eax
    and edx, 1
    shl edx, 2
    and eax, $FFFFFFFC
    mov eax, [eax+edx+4]
  end;
  {$ELSE}
  near; assembler;
  asm
    mov ax, Cursor.Word[2]
    mov es, ax
    mov di, Cursor.Word[0]
    mov ax, di
    and ax, $FFFC
    xchg ax, di
    and ax, 1
    shl ax, 1
    shl ax, 1
    add di, ax
    mov ax, es:[di+4]
    mov dx, es:[di+6]
  end;
  {$ENDIF}
{--------}
{-Converts a parent node and child relationship into a cursor}
function Csr(P : PNode; C : TChild) : TTreeCursor;
  {$IFDEF Win32}
  begin
    Result := TTreeCursor(longint(P) or Ord(C))
  end;
  {$ELSE}
  inline($58/            {pop ax      get child}
         $25/$01/$00/    {and ax, 1   isolate child bit}
         $5B/            {pop bx      get offset}
         $09/$D8/        {or ax, bx   xfer child bit}
         $5A);           {pop dx      get seg/sel}
  {$ENDIF}
{--------}
{-Sets the cursor's color bit to zero}
function Bleach(Cursor : TTreeCursor) : TTreeCursor;
  {$IFDEF Win32}
  begin
    Result := (Cursor and $FFFFFFFD);
  end;
  {$ELSE}
  inline ($58/           {pop ax      get offset}
          $25/$FD/$FF/   {and ax, XX  set off color bit}
          $5A);          {pop dx      get seg/sel}
  {$ENDIF}
{--------}
{-Sets the cursor's color bit to the same as a PKC link}
function Dye(Cursor, PKC : TTreeCursor) : TTreeCursor;
  {$IFDEF Win32}
  begin
    Result := (Cursor and $FFFFFFFD) or (PKC and $2);
  end;
  {$ELSE}
  inline ($58/             {pop ax      get color word}
          $25/$02/$00/     {and ax, 2   isolate color bit}
          $5B/             {pop bx      toss next}
          $5B/             {pop bx      get offset}
          $81/$E3/$FD/$FF/ {and bx, XX  kill color}
          $09/$D8/         {or ax, bx   xfer color bit}
          $5A);            {pop dx      get seg/sel}
  {$ENDIF}

{=TBinTree============================================================
A simple binary tree.

A binary tree is a data structure where each node has up to two
children, and one parent. This implementation makes a distinction
between external nodes (that have no children at all) and internal
nodes (that always have two children). External nodes are called
leaves. The object uses external cursors to navigate the tree (these
are NOT the nodes themselves). You position a given cursor in the tree
by moving it with the object's methods, and can use a cursor to insert
and delete data objects in the tree (although there are restrictions
on where this can happen).

The object has two iterators, and four methods to traverse the tree
with them. The four traversal methods are pre-order, in-order,
post-order and level-order. Note that JDS can be compiled in two modes
distinguished by the compiler define: UseTreeRecursion. If this is
active, recursive routines are used wherever required to implement
traversals; if not, then a TStack will be used to unravel the
recursion.
======================================================================}
constructor TBinTree.Create(DataOwner : boolean);
  begin
    NodeSize := 16;
    inherited Create(DataOwner);

    FTravType := ttInOrder;

    Rt := acNewNode(nil);
    FCount := 0;
  end;
{--------}
constructor TBinTree.Clone(Source : TAbstractContainer;
                           DataOwner : boolean;
                           NewCompare : TCompareFunc);
  var
    OldTree : TBinTree absolute Source;
    NewData : pointer;

  {$IFDEF UseTreeRecursion}
  procedure CloneTree(OldWalker, NewWalker : TTreeCursor);
    var
      Temp, NewTemp : TTreeCursor;
    begin
      NewData := nil;
      try
        Temp := OldTree.Left(OldWalker);
        if not OldTree.IsLeaf(Temp) then
          begin
            if DataOwner then
                 NewData := DupData(OldTree.Examine(Temp))
            else NewData := OldTree.Examine(Temp);
            NewTemp := Left(NewWalker);
            Insert(NewTemp, NewData);
            NewData := nil;
            CloneTree(Temp, NewTemp);
          end;
        Temp := OldTree.Right(OldWalker);
        if not OldTree.IsLeaf(Temp) then
          begin
            if DataOwner then
                 NewData := DupData(OldTree.Examine(Temp))
            else NewData := OldTree.Examine(Temp);
            NewTemp := Right(NewWalker);
            Insert(NewTemp, NewData);
            NewData := nil;
            CloneTree(Temp, NewTemp);
          end;
      finally
        if DataOwner and Assigned(NewData) then
          DisposeData(NewData);
      end;
    end;
  {$ELSE}
  procedure CloneTree;
    var
      StackOld, StackNew : TStack;
      OldWalker, NewWalker : TTreeCursor;
      Temp, NewTemp : TTreeCursor;
      Color : longint;
    begin
      StackOld := nil;
      StackNew := nil;
      NewData := nil;
      try
        StackOld := TStack.Create(false);
        StackNew := TStack.Create(false);
        if DataOwner then
             NewData := DupData(OldTree.Examine(OldTree.Root))
        else NewData := OldTree.Examine(OldTree.Root);
        NewTemp := Root;
        Insert(NewTemp, NewData);
        NewData := nil;
        StackOld.Push(pointer(OldTree.Root));
        StackNew.Push(pointer(Root));
        repeat
          OldWalker := TTreeCursor(StackOld.Pop);
          NewWalker := TTreeCursor(StackNew.Pop);
          Temp := OldTree.Left(OldWalker);
          if not OldTree.IsLeaf(Temp) then
            begin
              if DataOwner then
                   NewData := DupData(OldTree.Examine(Temp))
              else NewData := OldTree.Examine(Temp);
              NewTemp := Left(NewWalker);
              Insert(NewTemp, NewData);
              NewData := nil;
              StackOld.Push(pointer(Temp));
              StackNew.Push(pointer(NewTemp));
            end;
          Temp := OldTree.Right(OldWalker);
          if not OldTree.IsLeaf(Temp) then
            begin
              if DataOwner then
                   NewData := DupData(OldTree.Examine(Temp))
              else NewData := OldTree.Examine(Temp);
              NewTemp := Right(NewWalker);
              Insert(NewTemp, NewData);
              NewData := nil;
              StackOld.Push(pointer(Temp));
              StackNew.Push(pointer(NewTemp));
            end;
        until StackOld.IsEmpty;
      finally
        StackOld.Free;
        StackNew.Free;
        if DataOwner and Assigned(NewData) then
          DisposeData(NewData);
      end;
    end;
  {$ENDIF}
  var
    NewTemp : TTreeCursor;
  begin
    Create(DataOwner);
    Compare := NewCompare;
    DupData := OldTree.DupData;
    DisposeData := OldTree.DisposeData;

    if not (Source is TBinTree) then
      RaiseError(escBadSource);

    if OldTree.IsEmpty then Exit;

    try
      NewData := nil;
      {$IFDEF UseTreeRecursion}
      if DataOwner then
           NewData := DupData(OldTree.Examine(OldTree.Root))
      else NewData := OldTree.Examine(OldTree.Root);
      NewTemp := Root;
      Insert(NewTemp, NewData);
      NewData := nil;
      CloneTree(OldTree.Root, Root);
      {$ELSE}
      CloneTree;
      {$ENDIF}
    except
      if DataOwner and Assigned(NewData) then
        DisposeData(NewData);
      raise;
    end;{try..except}
  end;
{--------}
function TBinTree.Delete(Cursor : TTreeCursor) : TTreeCursor;
  var
    NewKid,
    LeftKid,
    RightKid : TTreeCursor;
    NodeToGo,
    Node : PNode;
  begin
    if IsLeaf(Cursor) then
      RaiseError(escDelInvalidHere);
    RightKid := Right(Cursor);
    LeftKid := Left(Cursor);
    if not IsLeaf(RightKid) then
      if not IsLeaf(LeftKid) then
        RaiseError(escDelInvalidHere)
      else
        NewKid := RightKid
    else
      NewKid := LeftKid;
    Delete := Cursor;
    Node := GetNode(NewKid);
    NodeToGo := GetNode(Cursor);
    Dad(Cursor)^.TLink[Kid(Cursor)] := Node;
    if not IsLeaf(NewKid) then
      with Node^ do
        PKC := Dye(Cursor, PKC);
    acDisposeNode(NodeToGo);
  end;
{--------}
procedure TBinTree.Empty;
{$IFDEF UseTreeRecursion}
  {------}
  procedure RecursePostOrder(Cursor : TTreeCursor);
    begin
      if not IsLeaf(Cursor) then
        begin
          RecursePostOrder(Left(Cursor));
          RecursePostOrder(Right(Cursor));
          if IsDataOwner then
            DisposeData(Examine(Cursor));
          acDisposeNode(GetNode(Cursor));
        end;
    end;
  {------}
  begin
    if not IsEmpty then
      begin
        RecursePostOrder(Root);
        Rt^.TLink[CRight] := nil;
      end;
    if InDone then
      if Assigned(Rt) then
        acDisposeNode(Rt);
  end;
{$ELSE}
  const
    Sentinel = 0;
  var
    Walker: TTreeCursor;
    Stack : TStack;
  begin
    if not IsEmpty then
      begin
        Stack := TStack.Create(false);
        try
          Stack.Push(pointer(Root));
          repeat
            Walker := TTreeCursor(Stack.Examine);
            if (Walker = Sentinel) then
              begin
                Walker := TTreeCursor(Stack.Pop);
                Walker := TTreeCursor(Stack.Pop);
                if IsDataOwner then
                  DisposeData(Examine(Walker));
                acDisposeNode(GetNode(Walker));
              end
            else
              begin
                Stack.Push(pointer(Sentinel));
                if not IsLeaf(Right(Walker)) then
                  Stack.Push(pointer(Right(Walker)));
                if not IsLeaf(Left(Walker)) then
                  Stack.Push(pointer(Left(Walker)));
              end;
          until (Stack.IsEmpty);
        finally
          Stack.Free;
        end;{try..finally}
        Rt^.TLink[CRight] := nil;
      end;
    if InDone then
      if Assigned(Rt) then
        acDisposeNode(Rt);
  end;
{$ENDIF}
{--------}
function TBinTree.Erase(Cursor : TTreeCursor) : TTreeCursor;
  begin
    if IsDataOwner then
      DisposeData(Examine(Cursor));
    Erase := Delete(Cursor);
  end;
{--------}
function  TBinTree.Examine(Cursor : TTreeCursor) : pointer;
  begin
    {$IFDEF DEBUG}
    Assert(not IsEmpty, ascEmptyExamine);
    Assert(not IsLeaf(Cursor), ascExamineLeaf);
    {$ENDIF}
    Examine := GetNode(Cursor)^.Data;
  end;
{--------}
procedure TBinTree.Insert(var Cursor : TTreeCursor; aData : pointer);
  var
    Node : PNode;
  begin
    if not IsLeaf(Cursor) then
      RaiseError(escInsInvalidHere)
    else
      begin
        Node := acNewNode(aData);
        Node^.PKC := Cursor;
        Dad(Cursor)^.TLink[Kid(Cursor)] := Node;
      end;
  end;
{--------}
function  TBinTree.IsLeaf(Cursor : TTreeCursor) : boolean;
  begin
    IsLeaf := GetNode(Cursor) = nil;
  end;
{--------}
function  TBinTree.IsRoot(Cursor : TTreeCursor) : boolean;
  begin
    IsRoot := Dad(Cursor) = Rt;
  end;
{--------}
function  TBinTree.Iterate(Action : TIterator; Backwards : boolean;
                           ExtraData : pointer) : TTreeCursor;
  {------}
  function TraverseLevelOrder : TTreeCursor;
    var
      Finished : boolean;
      Walker: TTreeCursor;
      Queue : TQueue;
    begin
      TraverseLevelOrder := 0;
      Finished := false;
      Queue := TQueue.Create(false);
      try
        Queue.Append(pointer(Root));
        repeat
          Walker := TTreeCursor(Queue.Pop);
          if not Action(Self, Examine(Walker), ExtraData) then  {!!.01}
            begin
              TraverseLevelOrder := Walker;
              Finished := true;
            end
          else if Backwards then
            begin
              if not IsLeaf(Right(Walker)) then
                Queue.Append(pointer(Right(Walker)));
              if not IsLeaf(Left(Walker)) then
                Queue.Append(pointer(Left(Walker)));
            end
          else
            begin
              if not IsLeaf(Left(Walker)) then
                Queue.Append(pointer(Left(Walker)));
              if not IsLeaf(Right(Walker)) then
                Queue.Append(pointer(Right(Walker)));
            end;
        until Finished or Queue.IsEmpty;
      finally
        Queue.Free;
      end;{try..finally}
    end;
  {------}
{$IFDEF UseTreeRecursion}
  function TraversePreOrder(Walker : TTreeCursor) : TTreeCursor;
    begin
      Result := 0;
      if not IsLeaf(Walker) then
        if not Action(Self, Examine(Walker), ExtraData) then    {!!.01}
          Result := Walker
        else
          begin
            Result := TraversePreOrder(Left(Walker));
            if (Result = 0) then
              Result := TraversePreOrder(Right(Walker));
          end;
    end;
  {------}
  function TraverseInOrder(Walker : TTreeCursor) : TTreeCursor;
    begin
      Result := 0;
      if not IsLeaf(Walker) then
        begin
          Result := TraverseInOrder(Left(Walker));
          if (Result = 0) then
            if not Action(Self, Examine(Walker), ExtraData) then {!!.01}
              Result := Walker
            else
              Result := TraverseInOrder(Right(Walker));
        end;
    end;
  {------}
  function TraversePostOrder(Walker : TTreeCursor) : TTreeCursor;
    begin
      Result := 0;
      if not IsLeaf(Walker) then
        begin
          Result := TraversePostOrder(Left(Walker));
          if (Result = 0) then
            begin
              Result := TraversePostOrder(Right(Walker));
              if (Result = 0) then
                if not Action(Self, Examine(Walker), ExtraData) then {!!.01}
                  Result := Walker;
            end;
        end;
    end;
  {------}
  function TraversePreOrderRev(Walker : TTreeCursor) : TTreeCursor;
    begin
      Result := 0;
      if not IsLeaf(Walker) then
        if not Action(Self, Examine(Walker), ExtraData) then    {!!.01}
          Result := Walker
        else
          begin
            Result := TraversePreOrderRev(Right(Walker));
            if (Result = 0) then
              Result := TraversePreOrderRev(Left(Walker));
          end;
    end;
  {------}
  function TraverseInOrderRev(Walker : TTreeCursor) : TTreeCursor;
    begin
      Result := 0;
      if not IsLeaf(Walker) then
        begin
          Result := TraverseInOrderRev(Right(Walker));
          if (Result = 0) then
            if not Action(Self, Examine(Walker), ExtraData) then {!!.01}
              Result := Walker
            else
              Result := TraverseInOrderRev(Left(Walker));
        end;
    end;
  {------}
  function TraversePostOrderRev(Walker : TTreeCursor) : TTreeCursor;
    begin
      Result := 0;
      if not IsLeaf(Walker) then
        begin
          Result := TraversePostOrderRev(Right(Walker));
          if (Result = 0) then
            begin
              Result := TraversePostOrderRev(Left(Walker));
              if (Result = 0) then
                if not Action(Self, Examine(Walker), ExtraData) then {!!.01}
                  Result := Walker;
            end;
        end;
    end;
  {------}
  begin
    if Backwards then
      case FTravType of
        ttPreOrder   : Result := TraversePreOrderRev(Root);
        ttInOrder    : Result := TraverseInOrderRev(Root);
        ttPostOrder  : Result := TraversePostOrderRev(Root);
        ttLevelOrder : Result := TraverseLevelOrder;
      end{case}
    else
      case FTravType of
        ttPreOrder   : Result := TraversePreOrder(Root);
        ttInOrder    : Result := TraverseInOrder(Root);
        ttPostOrder  : Result := TraversePostOrder(Root);
        ttLevelOrder : Result := TraverseLevelOrder;
      end;{case}
  end;
{$ELSE}
  const
    Sentinel = 0;
  function TraversePreOrder : TTreeCursor;
    var
      Walker: TTreeCursor;
      Stack : TStack;
      Finished : boolean;
    begin
      Result := 0;
      Finished := false;
      Stack := TStack.Create(false);
      try
        Stack.Push(pointer(Root));
        repeat
          Walker := TTreeCursor(Stack.Pop);
          if not Action(Self, Examine(Walker), ExtraData) then  {!!.01}
            begin
              Result := Walker;
              Finished := true;
            end
          else if Backwards then
            begin
              if not IsLeaf(Left(Walker)) then
                Stack.Push(pointer(Left(Walker)));
              if not IsLeaf(Right(Walker)) then
                Stack.Push(pointer(Right(Walker)));
            end
          else
            begin
              if not IsLeaf(Right(Walker)) then
                Stack.Push(pointer(Right(Walker)));
              if not IsLeaf(Left(Walker)) then
                Stack.Push(pointer(Left(Walker)));
            end;
        until Finished or Stack.IsEmpty;
      finally
        Stack.Free;
      end;{try..finally}
    end;
  {------}
  function TraverseInOrder : TTreeCursor;
    var
      Walker: TTreeCursor;
      Stack : TStack;
      Finished : boolean;
    begin
      Result := 0;
      Finished := false;
      Stack := TStack.Create(false);
      try
        Stack.Push(pointer(Root));
        repeat
          Walker := TTreeCursor(Stack.Pop);
          if (Walker = Sentinel) then
            begin
              Walker := TTreeCursor(Stack.Pop);
              if not Action(Self, Examine(Walker), ExtraData) then {!!.01}
                begin
                  Result := Walker;
                  Finished := true;
                end;
            end
          else if Backwards then
            begin
              if not IsLeaf(Left(Walker)) then
                Stack.Push(pointer(Left(Walker)));
              Stack.Push(pointer(Walker));
              Stack.Push(pointer(Sentinel));
              if not IsLeaf(Right(Walker)) then
                Stack.Push(pointer(Right(Walker)));
            end
          else
            begin
              if not IsLeaf(Right(Walker)) then
                Stack.Push(pointer(Right(Walker)));
              Stack.Push(pointer(Walker));
              Stack.Push(pointer(Sentinel));
              if not IsLeaf(Left(Walker)) then
                Stack.Push(pointer(Left(Walker)));
            end;
        until Finished or Stack.IsEmpty;
      finally
        Stack.Free;
      end;{try..finally}
    end;
  {------}
  function TraversePostOrder : TTreeCursor;
    var
      Walker: TTreeCursor;
      Stack : TStack;
      Finished : boolean;
    begin
      Result := 0;
      Finished := false;
      Stack := TStack.Create(false);
      try
        Stack.Push(pointer(Root));
        repeat
          Walker := TTreeCursor(Stack.Examine);
          if (Walker = Sentinel) then
            begin
              Walker := TTreeCursor(Stack.Pop);
              Walker := TTreeCursor(Stack.Pop);
              if not Action(Self, Examine(Walker), ExtraData) then {!!.01}
                begin
                  Result := Walker;
                  Finished := true;
                end;
            end
          else if Backwards then
            begin
              Stack.Push(pointer(Sentinel));
              if not IsLeaf(Left(Walker)) then
                Stack.Push(pointer(Left(Walker)));
              if not IsLeaf(Right(Walker)) then
                Stack.Push(pointer(Right(Walker)));
            end
          else
            begin
              Stack.Push(pointer(Sentinel));
              if not IsLeaf(Right(Walker)) then
                Stack.Push(pointer(Right(Walker)));
              if not IsLeaf(Left(Walker)) then
                Stack.Push(pointer(Left(Walker)));
            end;
        until Finished or Stack.IsEmpty;
      finally
        Stack.Free;
      end;{try..finally}
    end;
  {------}
  begin
    if IsEmpty then
      Result := 0
    else
      case FTravType of
        ttPreOrder   : Result := TraversePreOrder;
        ttInOrder    : Result := TraverseInOrder;
        ttPostOrder  : Result := TraversePostOrder;
        ttLevelOrder : Result := TraverseLevelOrder;
      end;{case}
  end;
{$ENDIF}
{--------}
procedure TBinTree.Join(Cursor : TTreeCursor; Tree : TBinTree);
  var
    RootNode : PNode;
  begin
    if not IsLeaf(Cursor) then
      RaiseError(escInsInvalidHere)
    else
      if Assigned(Tree) then
        begin
          if not Tree.IsEmpty then
            begin
              RootNode := GetNode(Tree.Root);
              RootNode^.PKC := Cursor;
              Dad(Cursor)^.TLink[Kid(Cursor)] := RootNode;
              inc(FCount, Tree.Count);
              {patch up Tree}
              with Tree do
                begin
                  Rt^.TLink[CRight] := nil;
                  FCount := 0;
                end;
            end;
          Tree.Free;
      end;
  end;
{--------}
function  TBinTree.Left(Cursor : TTreeCursor) : TTreeCursor;
  begin
    if IsLeaf(Cursor) then
      RaiseError(escCannotMoveHere)
    else
      Left := Csr(GetNode(Cursor), CLeft);
  end;
{--------}
function  TBinTree.Parent(Cursor : TTreeCursor) : TTreeCursor;
  begin
    if IsRoot(Cursor) then
      RaiseError(escCannotMoveHere)
    else
      Parent := Bleach(Dad(Cursor)^.PKC);
  end;
{--------}
function  TBinTree.Replace(Cursor : TTreeCursor; aData : pointer) : pointer;
  begin
    {$IFDEF DEBUG}
    Assert(not IsLeaf(Cursor), ascExamineLeaf);
    {$ENDIF}
    with GetNode(Cursor)^ do
       begin
         Replace := Data;
         Data := aData;
       end;
  end;
{--------}
function  TBinTree.Right(Cursor : TTreeCursor) : TTreeCursor;
  begin
    if IsLeaf(Cursor) then
      RaiseError(escCannotMoveHere)
    else
      Right := Csr(GetNode(Cursor), CRight);
  end;
{--------}
function  TBinTree.Root : TTreeCursor;
  begin
    Root := Csr(Rt, CRight);
  end;
{--------}
function  TBinTree.Search(var Cursor : TTreeCursor; aData : pointer) : boolean;
{$IFDEF UseTreeRecursion}
  {------}
  function RecursePreOrder(Walker : TTreeCursor) : boolean;
    begin
      if IsLeaf(Walker) then
        RecursePreOrder := false
      else if (Compare(Examine(Walker), aData) = 0) then
        begin
          RecursePreOrder := true;
          Cursor := Walker;
        end
      else if RecursePreOrder(Left(Walker)) then
        RecursePreOrder := true
      else
        RecursePreOrder := RecursePreOrder(Right(Walker));
    end;
  {------}
  begin
    Search := RecursePreOrder(Root);
  end;
{$ELSE}
  var
    Walker: TTreeCursor;
    Stack : TStack;
    FoundIt : boolean;
  begin
    FoundIt := false;
    Stack := TStack.Create(false);
    try
      Stack.Push(pointer(Root));
      repeat
        Walker := TTreeCursor(Stack.Pop);
        if (Compare(Examine(Walker), aData) = 0) then
          begin
            FoundIt := true;
            Cursor := Walker;
          end
        else
          begin
            if not IsLeaf(Right(Walker)) then
              Stack.Push(pointer(Right(Walker)));
            if not IsLeaf(Left(Walker)) then
              Stack.Push(pointer(Left(Walker)));
          end;
      until FoundIt or Stack.IsEmpty;
    finally
      Stack.Free;
    end;{try..finally}
    Search := FoundIt;
  end;
{$ENDIF}
{---------------------------------------------------------------------}

{-An iterator for cloning a binary search tree}
function BSTreeCloneData(C : TAbstractContainer;
                         aData : pointer;
                         ExtraData : pointer) : boolean; far;
  var
    NewTree : TBinTree absolute ExtraData;
    DummyCursor : TTreeCursor;
    NewData : pointer;
  begin
    Result := true;
    NewData := nil;
    try
      with NewTree do
        begin
          if IsDataOwner then
               NewData := DupData(aData)
          else NewData := aData;
          Insert(DummyCursor, NewData);
        end;
    except
      if NewTree.IsDataOwner then
        NewTree.DisposeData(NewData);
      raise;
    end;{try..except}
  end;

{-An iterator for joining a binary search tree}
function BSTreeJoinData(C : TAbstractContainer;
                        aData : pointer;
                        ExtraData : pointer) : boolean; far;
  var
    OurTree : TBinSearchTree absolute ExtraData;
    DummyCursor : TTreeCursor;
  begin
    Result := true;
    OurTree.Insert(DummyCursor, aData);
  end;

{=TBinSearchTree======================================================
A binary search tree

A sorted binary tree where for any given data object, all data objects
in its left subtree are less than it, and all data objects in the
right subtree are greater than it. This ordering relies on the Compare
method to be overridden.
======================================================================}
constructor TBinSearchTree.Clone(Source : TAbstractContainer;
                                 DataOwner : boolean;
                                 NewCompare : TCompareFunc);
  var
    OldTree : TBinSearchTree absolute Source;
    SaveTravType : TTraversalType;
  begin
    Create(DataOwner);
    Compare := NewCompare;
    DupData := OldTree.DupData;
    DisposeData := OldTree.DisposeData;

    if not (Source is TBinTree) then
      RaiseError(escBadSource);

    if OldTree.IsEmpty then Exit;

    SaveTravType := OldTree.TraversalType;
    OldTree.TraversalType := ttPostOrder;
    try
      OldTree.Iterate(BSTreeCloneData, false, Self);
    finally
      OldTree.TraversalType := SaveTravType;
    end;{try..finally}
  end;
{--------}
function  TBinSearchTree.Delete (Cursor : TTreeCursor) : TTreeCursor;
  var
    Walker,
    LeftChild : TTreeCursor;
  begin
    if IsLeaf(Cursor) then
      RaiseError(escDelInvalidHere);
    if IsLeaf(Left(Cursor)) or IsLeaf(Right(Cursor)) then
      Delete := inherited Delete(Cursor)
    else {both children exist}
      begin
        Walker := Right(Cursor);
        LeftChild := Left(Walker);
        while not IsLeaf(LeftChild) do
          begin
            Walker := LeftChild;
            LeftChild := Left(Walker);
          end;
        bsSwapData(Cursor, Walker);
        Delete := inherited Delete(Walker);
      end;
  end;
{--------}
procedure TBinSearchTree.Insert(var Cursor : TTreeCursor; aData : pointer);
  begin
    if Search(Cursor, aData) then
      RaiseError(escInsertDup)
    else
      inherited Insert(Cursor, aData);
  end;
{--------}
procedure TBinSearchTree.Join(Cursor : TTreeCursor; Tree : TBinTree);
  begin
    if Assigned(Tree) then
      with Tree do
        begin
          TraversalType := ttPostOrder;
          Iterate(BSTreeJoinData, false, Self);
          FIsDataOwner := false;
          Free;
        end;
  end;
{--------}
function TBinSearchTree.Replace(Cursor : TTreeCursor; aData : pointer) : pointer;
  begin
    Replace := Examine(Cursor);
    Delete(Cursor);
    Insert(Cursor, aData);
  end;
{--------}
function  TBinSearchTree.Search(var Cursor : TTreeCursor; aData : pointer) : boolean;
  var
    CompResult : integer;
    Walker     : TTreeCursor;
  begin
    Walker := Root;
    if IsLeaf(Walker) then
      Search := false
    else
      begin
        CompResult := Compare(aData, Examine(Walker));
        if      (CompResult < 0) then Walker := Left(Walker)
        else if (CompResult > 0) then Walker := Right(Walker);
        while (not IsLeaf(Walker)) and (CompResult <> 0) do
          begin
            CompResult := Compare(aData, Examine(Walker));
            if      (CompResult < 0) then Walker := Left(Walker)
            else if (CompResult > 0) then Walker := Right(Walker);
          end;
        Search := (CompResult = 0);
      end;
    Cursor := Walker;
  end;
{--------}
procedure TBinSearchTree.bsSwapData(OldCursor, NewCursor : TTreeCursor);
  var
    Data : pointer;
  begin
    Data := GetNode(OldCursor)^.Data;
    GetNode(OldCursor)^.Data := GetNode(NewCursor)^.Data;
    GetNode(NewCursor)^.Data := Data;
  end;
{---------------------------------------------------------------------}

{$IFNDEF Win32}
type
  LH = record L, H : word; end;
{$ENDIF}

{=Red-black tree helper routines=====================================
These routines help out the red-black tree methods. ColorBlack colors
the cursor black, ColorRed colors the cursor red. IsBlack returns
true if the cursor is black, whereas IsRed returns true if is red.
18Jun95 JMB
======================================================================}
procedure ColorBlack(Cursor : TTreeCursor);
  {$IFDEF Win32}
  begin
    with GetNode(Cursor)^ do
      PKC := PKC and $FFFFFFFD;
  end;
  {$ELSE}
  near;
  begin
    with GetNode(Cursor)^ do
      LH(PKC).L := LH(PKC).L and $FFFD;
  end;
  {$ENDIF}
{--------}
function IsBlack(Cursor : TTreeCursor) : boolean;
  {$IFDEF Win32}
  var
    Temp : PNode;
  begin
    Temp := GetNode(Cursor);
    if Assigned(Temp) then
      IsBlack := (Temp^.PKC and 2) = 0
    else
      IsBlack := true;
  end;
  {$ELSE}
  near;
  var
    Temp : PNode;
  begin
    Temp := GetNode(Cursor);
    if Assigned(Temp) then
      IsBlack := (LH(Temp^.PKC).L and 2) = 0
    else
      IsBlack := true;
  end;
  {$ENDIF}
{--------}
procedure ColorRed(Cursor : TTreeCursor);
  {$IFDEF Win32}
  begin
    with GetNode(Cursor)^ do
      PKC := PKC or 2;
  end;
  {$ELSE}
  near;
  begin
    with GetNode(Cursor)^ do
      LH(PKC).L := LH(PKC).L or 2;
  end;
  {$ENDIF}
{--------}
function IsRed(Cursor : TTreeCursor) : boolean;
  {$IFDEF Win32}
  var
    Temp : PNode;
  begin
    Temp := GetNode(Cursor);
    if Assigned(Temp) then
      IsRed := (Temp^.PKC and 2) <> 0
    else
      IsRed := false;
  end;
  {$ELSE}
  near;
  var
    Temp : PNode;
  begin
    Temp := GetNode(Cursor);
    if Assigned(Temp) then
      IsRed := (LH(Temp^.PKC).L and 2) <> 0
    else
      IsRed := false;
  end;
  {$ENDIF}

{=TrbSearchTree======================================================
A red-black binary search tree

A red-black tree is a binary search tree with inbuilt balancing
algorithms during Insert and Delete. This ensures that the tree does
not degenerate into a sorted linked list, maintaining its excellent
search times.

The tree is called red-black because certain data objects are labelled
Black and the others are Red such that (1) every Red data object (that
is not at the root) has a Black parent, (2) each path from leaf to
root has the same number of Black data objects, and (3) each leaf is
Black. This set of rules ensures that the tree is (quite) balanced.

References
  Sedgewick: Algorithms
  Wood: Data Structures, Algorithms, and Performance

PS. I also apologise for the unpolitically correct terminology in this
source code! Thank you, Bryan, for pointing it out, but it's too late
now...
======================================================================}
function  TrbSearchTree.Delete(Cursor : TTreeCursor) : TTreeCursor;
  var
    Pa, Brother, Nephew1, Nephew2 : TTreeCursor;
    Balanced : boolean;
  begin
    DeletedNodeWasBlack := IsBlack(Cursor);
    Cursor := inherited Delete(Cursor);
    Delete := Cursor;
    repeat
      Balanced := true;
      if DeletedNodeWasBlack then
        if IsRed(Cursor) then
          ColorBlack(Cursor)
        else if not IsRoot(Cursor) then
          begin
            Pa := Parent(Cursor);
            if (Kid(Cursor) = CLeft) then
                 Brother := Right(Pa)
            else Brother := Left(Pa);
            if IsRed(Brother) then
              begin
                if IsBlack(Pa) then
                  ColorBlack(Brother);
                ColorRed(Pa);
                Brother := rbPromote(Brother);
                if (Kid(Cursor) = CLeft) then
                     Cursor := Left(Left(Brother))
                else Cursor := Right(Right(Brother));
                Balanced := false;
              end
            else {Brother is black}
              begin
                if (Kid(Cursor) = CLeft) then
                     Nephew1 := Right(Brother)
                else Nephew1 := Left(Brother);
                if IsRed(Nephew1) then
                  begin
                    ColorBlack(Nephew1);
                    if IsRed(Pa) then
                      ColorRed(Brother);
                    ColorBlack(Pa);
                    Brother := rbPromote(Brother);
                  end
                else {Nephew1 is black}
                  begin
                    if (Kid(Cursor) = CLeft) then
                         Nephew2 := Left(Brother)
                    else Nephew2 := Right(Brother);
                    if IsRed(Nephew2) then
                      begin
                        if IsBlack(Pa) then
                          ColorBlack(Nephew2);
                        ColorBlack(Pa);
                        Nephew2 := rbPromote(rbPromote(Nephew2));
                      end
                    else {Nephew2 is black}
                      if IsRed(Pa) then
                        begin
                          ColorBlack(Pa);
                          ColorRed(Brother);
                        end
                      else {Pa is black}
                        begin
                          ColorRed(Brother);
                          Cursor := Pa;
                          Balanced := false;
                        end;
                  end;
              end;
          end;
    until Balanced;
  end;
{--------}
procedure TrbSearchTree.Insert(var Cursor : TTreeCursor; aData : pointer);
  var
    Pa, GrandPa, Uncle : TTreeCursor;
    Balanced : boolean;
  begin
    inherited Insert(Cursor, aData);
    ColorRed(Cursor);
    repeat
      Balanced := true;
      if not IsRoot(Cursor) then
        begin
          Pa := Parent(Cursor);
          if IsRed(Pa) then
            if IsRoot(Pa) then
              ColorBlack(Pa)
            else
              begin
                GrandPa := Parent(Pa);
                ColorRed(GrandPa);
                if (Kid(Pa) = CLeft) then
                     Uncle := Right(GrandPa)
                else Uncle := Left(GrandPa);
                if IsRed(Uncle) then
                  begin
                    ColorBlack(Pa);
                    ColorBlack(Uncle);
                    Cursor := GrandPa;
                    Balanced := false;
                  end
                else {Uncle is black}
                  if (Kid(Cursor) = Kid(Pa)) then
                    begin
                      ColorBlack(Pa);
                      Pa := rbPromote(Pa);
                    end
                  else
                    begin
                      ColorBlack(Cursor);
                      Cursor := rbPromote(rbPromote(Cursor));
                    end;
              end;
        end;
    until Balanced;
  end;
{--------}
function TrbSearchTree.rbPromote(Cursor : TTreeCursor) : TTreeCursor;
  var
    NodeX,
    NodeP,
    XSon  : PNode;
  begin
    NodeX := GetNode(Cursor);
    NodeP := Dad(Cursor);

    with NodeP^ do
      begin
        Dad(PKC)^.TLink[Kid(PKC)] := NodeX;
        NodeX^.PKC := Dye(PKC, NodeX^.PKC);
      end;

    if (Kid(Cursor) = CLeft) then
      begin
        XSon := NodeX^.TLink[CRight];
        NodeX^.TLink[CRight] := NodeP;
        NodeP^.PKC := Dye(Csr(NodeX, CRight), NodeP^.PKC);
        NodeP^.TLink[CLeft] := XSon;
        if (XSon <> nil) then
          XSon^.PKC := Dye(Cursor, XSon^.PKC);
      end
    else
      begin
        XSon := NodeX^.TLink[CLeft];
        NodeX^.TLink[CLeft] := NodeP;
        NodeP^.PKC := Dye(Csr(NodeX, CLeft), NodeP^.PKC);
        NodeP^.TLink[CRight] := XSon;
        if (XSon <> nil) then
          XSon^.PKC := Dye(Cursor, XSon^.PKC);
      end;

    rbPromote := Bleach(NodeX^.PKC);
  end;
{--------}
procedure TrbSearchTree.bsSwapData(OldCursor, NewCursor : TTreeCursor);
  begin
    DeletedNodeWasBlack :=  IsBlack(NewCursor);
    inherited bsSwapData(OldCursor, NewCursor);
  end;
{---------------------------------------------------------------------}

end.